home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Module source / Util < prev    next >
Text File  |  1992-10-25  |  6KB  |  241 lines
  1. \ Utility words for Yerk
  2. \ 10/13/84  CBD Combined with Dump.scr
  3. \ 12/16/84  CBD Made into a module
  4. \  1/04/85  cdn Moved in objList
  5. \  7/10/86  cdn Moved in .classes
  6. \  9/02/86  cdn Added Option & Shift key features to WORDS
  7. \  9/04/86  ghs Added pat
  8. \ 12/04/87  rfl modified .cline to use better format and increased clist size
  9. \ 12/04/87    rfl fixed dump format
  10. \ 10/02/90    rfl    .pause now in nucleus
  11. \ 10/26/91    rfl    added class hierarchy
  12. \ 12/14/91    rfl    modified .class to not be reentrant..runs out of stack
  13. \ 12/17/91    rfl    improved hier...someday will have browser
  14. \ 10/16/92    rfl    added listing of objects in .clist
  15. Decimal
  16.  
  17. :Module Util
  18.  
  19. : Dump
  20.     base >R HEX CR CR
  21.     ." Dump from address: " over . CR 7 SPACES
  22.     16 0 DO I 3 .R LOOP 2 SPACES
  23.         16 0 DO I 0 <# # #> TYPE LOOP CR
  24.         OVER + SWAP DUP 15 AND XOR
  25.         DO    CR i 0 6 D.R SPACE
  26.             i 16 + i 2DUP
  27.             DO  ic@ SPACE 0 <# # # #> TYPE LOOP
  28.             2 SPACES
  29.             DO  ic@ DUP 32 < OVER 126 > OR
  30.                 IF DROP 46   THEN
  31.                 EMIT
  32.             LOOP
  33.         ?pause
  34.         16 +LOOP
  35.     CR R> -> BASE ;
  36.  
  37. \ pull name from stream and dump from its NFA
  38. : .W    @Pfa  nfa 100 Dump  ;
  39.  
  40. \ List words in dictionary
  41. : Words { \ eop wbase -- }
  42.     latest true
  43.     mods: fEvent 2048 and    \ option key is down- prompt for word name
  44.     IF    2drop " List from name:" doInDlg dup
  45.         IF    drop sFind 0= Abort" not found"
  46.             drop nfa true
  47.         THEN
  48.     THEN
  49.     mods: fEvent  512 and    \ shift key is down- prompt for address
  50.     IF    2drop " List from hex address:" doInDlg dup
  51.         IF    drop here >str255 1+ here c@ >uc
  52.             BL here count + c!        \ make usable by "number"
  53.             base -> wbase hex
  54.             here number drop 0 max latest
  55.             BEGIN 2dup pfa lfa @ <    \ find the nearest word
  56.             WHILE pfa lfa @
  57.             REPEAT swap drop true
  58.             wbase -> base
  59.         THEN
  60.     THEN
  61.     0= IF exit THEN    \ Cancel button from a dialog box
  62.     getvrect: fWind drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop
  63.     Base -> wbase HEX  Cr Cr 0 -> out
  64.     BEGIN
  65.         dup dup 6 .R
  66.         dup  1+ C@
  67.         IF  space ID.
  68.         ELSE  ."  Null" drop
  69.         THEN out eop >
  70.         IF  Cr 0 -> Out
  71.         ELSE  20 out over mod - spaces
  72.         THEN  pfa lfa @ dup 0=
  73.         ?Pause
  74.     UNTIL
  75.     drop Cr wbase -> Base ;
  76.  
  77. \ trav handler for finding objects of a class
  78. : ofind { theCfa theClass -- }
  79.     theCfa @ theClass =
  80.     IF cr theCfa >name dup id.  .h  THEN   ;
  81.  
  82. : objList {  addr len \ theClass -- } addr len sFind
  83.     0= ?error 122
  84.     drop  ?isClass 0= ?error 122   -> theClass
  85.     cr ." Objects of class: " addr len type
  86.     'c ofind theClass trav  cr ;
  87.  
  88. 0 value cList
  89. 0 value level
  90. 0 value #obs
  91.  
  92. hex    \ changes text in place
  93. Create >lc    ( addr len -- addr len )
  94.     2e17    w,    \         move.l    (sp),d7
  95.     206f0004 ,    \         move.l    4(sp),a0
  96.     d1cb    w,    \         adda.l    a3,a0
  97.     5387    w,    \         subq    #1,d7
  98.     1018    w,    \ lp    move.b    (a0)+,d0
  99.     0c000041 ,    \         cmpi.b    #65,d0
  100.     6b0e    w,    \         bmi.s    out
  101.     0c00005a ,    \         cmpi.b    #90,d0
  102.     6e08    w,    \         bgt.s    out
  103.     d03c0020 ,    \         add.b    #32,d0
  104.     1140ffff ,    \         move.b    d0,-1(a0)
  105.     51cfffe8 ,    \ out    dbra    d7,lp
  106. next,
  107. decimal
  108.  
  109. \ trav handler for finding objects of a class
  110. : obfind { theCfa theClass \ len -- }
  111.     theCfa @ theClass =
  112.      IF cr level 1+ 2* spaces theCfa >name dup .h 2 spaces n>count -> len
  113.         here len cmove here len >lc type     \ move name to here
  114.         1 ++> #obs
  115.      THEN  ;
  116.  
  117. ' meta constant lastCl
  118.  
  119. \  Handler to add all classes to cList during a Trav
  120. : addClass { theCfa parm -- }
  121.     theCfa  lastCl >
  122.     IF  theCfa 4+ ?IsClass
  123.         IF  add: cList
  124.         ELSE drop
  125.         THEN
  126.     THEN ;
  127.  
  128. : fillClist   clear: clist 0 add: clist 'c addClass 0 trav   ;
  129.  
  130. \ ( ind -- ^super )
  131. : superOF  at: cList  sfa @  ;
  132.  
  133. \ find the next subclass for the given superclass ptr
  134. : nextSub { ^sup start \ bool -- subInd t OR f }
  135.     0 -> bool
  136.     size: cList  start
  137.     DO  i superOF  ^sup =
  138.         IF  i true -> bool  Leave
  139.         THEN
  140.     LOOP bool ;
  141.  
  142. : tab 6 * @xy drop - 6 / spaces ;
  143.  
  144. \ print a line of data for this class
  145. : .cline ( ind -- )
  146.     cr level 2* spaces
  147.     at: cList  dup dup nfa 4 tface id. 0 tface
  148.     dup dfa w@ 35 tab ." Dlen:" .  dfa 2+ w@ 46 tab ." Width:" . 
  149.     'c obfind swap trav  ;
  150.  
  151. \ patch .cline .cline1
  152.  
  153. \ ( ind -- ind subInd t OR ind f )  try to nest into subclass
  154. : ?sub  dup at: clist 0 nextSub  ;
  155.  
  156. \ ( ind -- newInd t or f )  try to find a peer class
  157. : ?peer
  158.     dup superOF lastCL =
  159.     IF false  THEN
  160.     dup superOF  swap 1+ nextSub  ;
  161.  
  162. : findPeer { ind  -- ind }
  163.     BEGIN ind ?peer                        \ does it have a peer class?
  164.           IF -> ind true                 \ yes, so get out
  165.           ELSE -1 ++> level    level 0=    \ no, so pop up and do again
  166.                 IF 0 -> ind true
  167.                 ELSE -> ind false
  168.                 THEN
  169.           THEN
  170.     UNTIL ind  ;
  171.  
  172. : classTrav { ind -- }
  173.     BEGIN ?terminal
  174.           IF (key) drop cr .pause (key)
  175.              cr 0 -> out 32 > IF exit THEN
  176.           THEN
  177.           ind .cline
  178.           ind ?sub                            \ does it have a subclass?
  179.           IF   1 ++> level -> ind            \ yes, so dip down and save last class index
  180.           ELSE findPeer    -> ind                \ otherwise find next peer
  181.           THEN
  182.           ind not
  183.     UNTIL ;
  184.  
  185. : .cl  size: clist 0 DO i at: clist cr nfa id. LOOP  ;
  186.  
  187. : .classes 0 -> level 0 -> #obs
  188.     400 heap> Ordered-Col -> cList
  189.     fillClist  size: clist 1-  classTrav level 0 do drop loop cr cr
  190.     size: clist ." number of classes is " . cr 
  191.     #obs ." number of objects is " . cr
  192.     dispose> cList ;
  193.  
  194. rect pbox
  195.  
  196. \ Display the system pen patterns
  197. : pat { \ pattern -- }
  198.     0 -> pattern -curs cls
  199.     1 8 50 38 put: pbox 6 0
  200.     DO    7 0
  201.         DO    pattern 38 = IF 3 sysPat +base call PenPat THEN
  202.             55 0 offset: pbox  pattern sysPat fill: pbox  draw: pbox
  203.             getBotX: pbox 38 -  getBotY: pbox 9 +  gotoxy  pattern .
  204.             1 ++> pattern
  205.         LOOP
  206.         -385 40 offset: pbox
  207.     LOOP
  208.     0 sysPat +base call PenPat
  209.     CR +curs
  210. ;
  211.  
  212.  
  213. \ ************
  214. \ : (chain) { myobj \ tab -- } cr 0 -> tab
  215. \         BEGIN  2 ++> tab myObj sfa @ -> myObj
  216. \                myObj nfa n>count 2dup tab spaces type cr " OBJECT" s=
  217. \         UNTIL ;
  218.  
  219. : (chain) { myObj \ tab -- } 40 heap> ordered-col -> clist
  220.         cr 0 -> tab myObj add: clist
  221.         BEGIN    myObj sfa @ -> myObj
  222.                 myObj add: clist
  223.                 myObj nfa n>count  " OBJECT" s=
  224.         UNTIL 
  225.         size: clist 0
  226.         DO  2 ++> tab last: clist nfa n>count tab spaces type cr
  227.             size: clist 1- remove: clist
  228.         LOOP dispose> clist ;
  229.  
  230. : hc'
  231.     @word count sfind
  232.     IF drop (chain) THEN ;
  233.  
  234. : hier  " List class hierarchy of class:" doInDlg
  235.         IF  sFind 0= Abort" not found"
  236.             drop ?isclass IF (chain) ELSE abort" not a class" THEN
  237.         THEN ;
  238.             
  239.  
  240. ;Module
  241.